home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
tptc16.zip
/
TPCDECL.INC
< prev
next >
Wrap
Text File
|
1993-01-04
|
13KB
|
583 lines
(*
* TPTC - Turbo Pascal to C translator
*
* (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
*
*)
(********************************************************************)
(*
* process pascal data type specifications
*
*)
function psimpletype: string80;
{parse a simple (single keyword and predefined) type; returns the
translated type specification; sets the current data type}
var
ts: string80;
sym: symptr;
begin
ts := '';
repeat
if (tok = 'CHAR') or (tok = 'BYTE') then
begin
curtype := s_char;
cursuptype := ss_scalar;
curlimit := 255;
end
else
if tok = 'STRING' then
begin
curtype := s_string;
cursuptype := ss_scalar;
curlimit := 255;
end
else
if tok = 'TEXT' then
begin
curtype := s_file;
cursuptype := ss_scalar;
curlimit := 0;
end
else
if tok = 'LONGINT' then
begin
curtype := s_long;
cursuptype := ss_scalar;
curlimit := maxint;
end
else
if tok = 'BOOLEAN' then
begin
curtype := s_int;
cursuptype := ss_scalar;
curlimit := maxint;
end
else
if tok = 'INTEGER' then
begin
curtype := s_int;
cursuptype := ss_scalar;
curlimit := maxint;
end
else
if tok = 'REAL' then
begin
curtype := s_double;
cursuptype := ss_scalar;
curlimit := maxint;
end;
sym := locatesym(ltok);
if sym <> nil then
begin
curtype := sym^.symtype;
cursuptype := sym^.suptype;
curlimit := sym^.limit;
end;
if ts <> '' then
ts := ts + ' ' + ltok
else
ts := ltok;
gettok;
until (tok = ';') or (tok = ')') or (tok = '=') or (tok = '}');
psimpletype := ts;
end;
(********************************************************************)
procedure pdatatype(stoclass: anystring;
var vars: paramlist;
prefix: anystring;
suffix: anystring;
addsemi: boolean);
{parse any full data type specification; input is a list of variables
to be declared with this data type; stoclass is a storage class prefix
(usually 'static ', '', 'typedef ', or 'extern '. prefix and suffix
are variable name modifiers used in pointer and subscript translations;
recursive for complex data types}
const
forward_typedef: anystring = '';
forward_undef: anystring = '';
var
i: integer;
ts: anystring;
sym: symptr;
procedure pvarlist;
var
i: integer;
begin
for i := 1 to vars.n do
begin
newsym(vars.id[i],curtype,cursuptype,-1,0,curlimit);
write(ofd[level],' ',prefix,vars.id[i],suffix);
if i < vars.n then
write(ofd[level],',');
end;
end;
procedure parray;
begin
gettok; {consume the ARRAY}
gettok; {consume the [}
ts := pexpr; {consume the lower subscript expression}
if tok = '..' then
begin
gettok; {consume the ..}
ts := pexpr;
end;
sym := locatesym(ts);
if sym <> nil then
if (sym^.limit > 0) and (sym^.suptype <> ss_const) then
ts := ' /* ' + ts + ' */ ' + ftoa(sym^.limit,0,0);
suffix := '[' + ts + '+1]'; {increment array size by one}
gettok; {consume the ]}
gettok; {consume the OF}
cursuptype := ss_array;
end;
procedure pstring;
begin
gettok; {consume the STRING}
if tok = '[' then
begin
gettok; {consume the [}
ts := pexpr;
suffix := suffix + '[' + ts + '+1]'; {increment string size by one}
gettok; {consume the ]}
end
else
suffix := suffix + '[STRSIZ]';
write(ofd[level],stoclass,LJUST('char',identlen) );
curtype := s_string;
pvarlist;
end;
procedure ptext;
begin
gettok; {consume the TEXT}
if tok = '[' then
begin
gettok; {consume the [}
ts := pexpr;
gettok; {consume the ]}
end;
write(ofd[level],stoclass,LJUST('text',identlen));
curtype := s_file;
pvarlist;
end;
procedure pfile;
begin
gettok; {consume the FILE}
if tok = 'OF' then
begin
gettok; {consume the OF}
ts := tok;
gettok; {consume the recordtype}
end;
write(ofd[level],stoclass,LJUST('int',identlen),' /* file of ',ts,' */ ');
curtype := s_file;
pvarlist;
end;
procedure pset;
begin
gettok; {consume the SET}
gettok; {consume the OF}
pdatatype(stoclass,vars,'/* set of */ ','',false);
end;
procedure pvariant;
begin
gettok; {consume the CASE}
ts := ltok;
gettok; {consume the selector identifier}
if tok = ':' then
begin
gettok; {consume the :}
write(ofd[level], ltok,' ',ts, '; /* Variant Selector */');
gettok; {consume the selector type}
end
else
write(ofd[level],'/* Variant Selector is ',ts,' */');
if tok <> 'OF' then
syntax('OF expected (pvariant)');
gettok;
write(ofd[level],' union { ');
newline;
while tok <> '}' do
begin
ts := pexpr; {parse the selector constant}
while tok = ',' do
begin
gettok;
ts := pexpr;
end;
gettok; {consume the :}
write(ofd[level],' struct { ');
pvar;
gettok; {consume the ')'}
write(ofd[level],' } s',ts,';');
if tok = ';' then
gettok;
end;
write(ofd[level],' } v;');
newline;
end;
procedure precord;
begin
write(ofd[level],stoclass,'struct ',vars.id[1],' { ');
pvar; {process each record member}
if tok = 'CASE' then {process the variant part, if any}
pvariant;
puttok; {output the closing brace}
gettok; {and consume it}
curtype := s_struct;
cursuptype := ss_struct;
pvarlist; {output any variables of this record type}
{convert a #define into a typedef in case of a forward pointer decl}
if forward_typedef <> '' then
begin
writeln(ofd[level],';');
writeln(ofd[level],forward_undef);
write(ofd[level],forward_typedef);
forward_typedef := '';
end;
end;
procedure penum;
begin
write(ofd[level],stoclass,'enum { ');
gettok;
i := 0;
repeat
write(ofd[level],ltok);
inc(i);
gettok;
until tok = ')';
write(ofd[level],' }');
gettok; {consume the )}
curtype := s_int;
curlimit := i;
pvarlist;
end;
procedure pnumber;
begin
ts := pexpr; {consume the lower limit expression}
if tok <> '..' then
error('".." expected (pdatatype)');
gettok; {consume the ..}
ts := pexpr; {consume the number}
sym := locatesym(ts);
if sym <> nil then
if sym^.limit > 0 then
ts := ftoa(sym^.limit,0,0);
curtype := s_int;
curlimit := atoi(ts);
write(ofd[level],stoclass,LJUST('int',identlen),' /* limit=',ts,' */');
pvarlist;
end;
procedure psimple;
begin
ts := psimpletype;
i := pos('^',ts);
if i <> 0 then
begin
delete(ts,i,1);
prefix := '*';
end;
if (stoclass = 'typedef ') and (vars.n = 1) and (prefix = '*') then
begin
newsym(vars.id[1],curtype,cursuptype,-1,0,curlimit);
write(ofd[level],'#define ',LJUST(vars.id[1],identlen),' struct ',ts,' *');
forward_undef := '#undef '+vars.id[1];
forward_typedef := 'typedef struct '+ts+' *'+vars.id[1];
addsemi := false;
end
else
begin
write(ofd[level],stoclass,LJUST(ts,identlen));
pvarlist;
end;
end;
begin
curlimit := 0;
if tok = 'EXTERNAL' then
begin
gettok; {consume the EXTERNAL}
stoclass := 'extern '+stoclass;
end;
if tok = 'ARRAY' then
parray;
if tok = 'STRING' then pstring
else if tok = 'TEXT' then ptext
else if tok = 'FILE' then pfile
else if tok = 'SET' then pset
else if tok = '(' then penum
else if tok = 'RECORD' then precord
else if toktype = number then pnumber
else psimple;
if addsemi then
write(ofd[level],';');
if tok = ';' then
gettok;
end;
(********************************************************************)
(*
* declaration keyword processors
* const, type, var, label
*
* all enter with tok=section type
* exit with tok=new section or begin or proc or func
*
*)
procedure pconst;
{parse and translate a constant section}
var
vars: paramlist;
parlev: integer;
exp: string80;
begin
gettok;
while (toktype <> keyword) do
begin
nospace := false;
vars.n := 1;
vars.id[1] := ltok;
gettok; {consume the id}
if tok = '=' then {untyped constant}
begin
gettok; {consume the =}
exp := pexpr;
case exprtype(exp) of
'c': curtype := s_char;
'f': curtype := s_double;
's': curtype := s_string;
else curtype := s_int;
end;
write(ofd[level],'#define ',LJUST(vars.id[1],identlen),
' ',LJUST(exp,identlen));
newsym(vars.id[1],curtype,ss_const,-1,0,{0}atoi(exp));
gettok; {consume the ;}
end
else
begin {typed constants}
gettok; {consume the :}
pdatatype('static ',vars,'','',false);
gettok; {consume the =}
write(ofd[level],' = ');
parlev := 0;
repeat
if tok = '(' then
begin
inc(parlev);
write(ofd[level],'{');
gettok;
end
else
if tok = ')' then
begin
dec(parlev);
write(ofd[level],'}');
gettok;
end
else
if tok = ',' then
begin
puttok;
gettok;
end
else
if (parlev > 0) and (tok = ';') then
begin
write(ofd[level],',');
gettok;
end
else
if tok <> ';' then
begin
exp := pexpr;
if tok = ':' then
gettok {discard 'member-identifier :'}
else
write(ofd[level],exp);
end;
until (tok = ';') and (parlev = 0);
puttok; {output the final ;}
gettok;
end;
end;
end;
(********************************************************************)
procedure ptype;
{parse and translate a type section}
var
vars: paramlist;
begin
gettok;
while (toktype <> keyword) do
begin
vars.n := 1;
vars.id[1] := usetok;
if tok = '=' then
gettok
else
syntax('"=" expected (ptype)');
nospace := false;
pdatatype('typedef ',vars,'','',true);
end;
end;
(********************************************************************)
procedure pvar;
{parse and translate a variable section}
var
vars: paramlist;
begin
vars.n := 0;
gettok;
while (toktype <> keyword) and (tok <> '}') and (tok <> ')') do
begin
nospace := true;
repeat
if tok = ',' then
gettok;
inc(vars.n);
vars.id[vars.n] := ltok;
gettok;
until tok <> ',';
if tok <> ':' then
syntax('":" expected (pvar)')
else
gettok; {consume the :}
nospace := false;
pdatatype('',vars,'','',true);
vars.n := 0;
end;
end;
(********************************************************************)
procedure plabel;
{parse (and throw away) a label section}
begin
while tok <> ';' do
gettok;
gettok;
end;